home *** CD-ROM | disk | FTP | other *** search
/ BBS Toolkit / BBS Toolkit.iso / qbbs / ld_123.zip / LHDOOR.PAS < prev    next >
Pascal/Delphi Source File  |  1989-05-16  |  19KB  |  529 lines
  1. {PROGRAM     : LHDOOR 1.22
  2.  
  3.  AUTHORS     : Jan Maaskant(RBBS)  -        Expansions        - 692-0377
  4.                (1:387/301)
  5.                Jon Hamlin(QuickBBS)- The Programmers Paradise - 654-9134
  6.                (1:387/609)
  7.  
  8.  PURPOSE     : This isn't really a full scale door, and was never
  9.                meant to be,  it is meant more as a 'quick fix'
  10.                for use with a new file compression scheme until
  11.                one of the more inspired and talented folks out
  12.                out there decides to make a -real- LHarc door.
  13.  
  14.  OTHER STUFF : Jon and I continually slash at each other's code,
  15.                fact is you'll find a lot in here that was done by
  16.                either of us.  However we don't agree on a lot of
  17.                things,  and the version of this running on either
  18.                of our BBS's will usually look and feel -different-
  19.                Doesn't bother us,  if it bother's you your welcome
  20.                to slash the code into whatever shape you like,
  21.                just leave our names in (or suffer horrible
  22.                agony in the hereafter...) and shoot us a copy
  23.                if you did any good.
  24. }
  25.  
  26. {$M $4000,0,0}                     {Needed since we use the Exec function }
  27. Uses DOS;
  28.  
  29. var
  30.   choice        : string[1];
  31.   fname         : string[8];
  32.   NewFile       : String[8];
  33.   file_found    : boolean;
  34.   paths         : text;
  35.   path          : string[255];
  36.   fullfilename  : text;
  37.   killarcs      : text;
  38.   di            : Text;
  39.   ch            : string[1];
  40.   Dummy         : String[50];
  41.   i             : Integer;
  42.   U_Security    : Integer;
  43.   U_ANSI        : Integer;
  44.   Set_Sec       : Integer;
  45.   ValidChoice   : Boolean;
  46.   IndFName      : String[80];
  47.   Current       : String[255];
  48.   CmdStr        : String[255];
  49.   DelStr        : String[255];
  50.   Quick_bbs     : boolean;
  51.   Rbbs_bbs      : boolean;
  52.  
  53.  
  54. procedure get_params;
  55.   VAR count : integer;
  56.  
  57. begin
  58.    rbbs_bbs  := false;
  59.    quick_bbs := false;
  60.   if paramstr(1)='' then
  61.     begin
  62.       writeln('No parameters Specified.  Format is:');
  63.       writeln;
  64.       writeln('LHDOOR /q              for QuickBBS');
  65.       writeln('   or');
  66.       writeln('LHDOOR /r              for RBBS-PC');
  67.       writeln;
  68.       writeln('LHDOOR will continue in NON-GRAPHICS MODE');
  69.       writeln;
  70.     end;
  71.  
  72.     if paramcount > 0 then
  73.       for count := 1 to paramcount do
  74.         begin
  75.           if ((paramstr(count) = '/q' ) or
  76.               (paramstr(count) = '/Q')) then QUICK_BBS := TRUE;
  77.           if ((paramstr(count) = '/r' ) or
  78.               (paramstr(count) = '/R')) then RBBS_BBS  := TRUE;
  79.         end;
  80. end;
  81.  
  82.  
  83.  
  84. procedure colormenu;
  85. begin
  86.   writeln('╔══════════════════════════╡LHDOOR╞══════════════s');
  87.   writeln('u════════════╗H║         LHZ/ZIP/PAK/ARC Conversion s');
  88.   writeln('uand Viewing Door        ║H║                        s');
  89.   writeln('uVersion 1.23                        ║H║       s');
  90.   writeln('u                                                     ║H║s');
  91.   writeln('u         Support: RBBS-PC : (512)692-0377 - 1:387s');
  92.   writeln('u/301       ║H║                  QuickBBS: (512s');
  93.   writeln('u)654-9134 - 1:387/609       ║H║                    s');
  94.   writeln('u                                        ║H╟─────────────s');
  95.   writeln('u─────────────────┬─────────────────────────────╢H║ s');
  96.   writeln('uView                         │        Conversion s');
  97.   writeln('u          ║H║ ~~~~                         s');
  98.   writeln('u│        ~~~~~~~~~~           ║H║ [s');
  99.   writeln('uD] Display file inside LHARC│        s');
  100.   writeln('u[E] Self-extracting  ║H║ s');
  101.   writeln('u[F] File Listing             │   s');
  102.   writeln('u     [P] PAK file         ║H║s');
  103.   writeln('u [L] List                     │  s');
  104.   writeln('u      [S] SEA''s style ARC  ║');
  105.   writeln('H║ [O] Old style view           s');
  106.   writeln('u│        [Z] Zip Format       ║');
  107.   writeln('H║ [V] View                     s');
  108.   writeln('u│                             ║H║                    s');
  109.   writeln('u[Q] Quit back to BBS                 s');
  110.   writeln('u   ║H╚═════════════════════════════════════════════A');
  111.   writeln('C═══════════════╝');
  112.   write  (' Choice: ');
  113. end;
  114.  
  115. Procedure Graphmenu;
  116.   begin
  117.     writeln('┌────────────────────────────────────────────────────────┐');
  118.     writeln('│                   ░▒▓ LHDOOR ▓▒░                       │');
  119.     writeln('│                                                        │');
  120.     writeln('│  Support: RBBS-PC  : (1:387/301) (512)692-0377         │');
  121.     writeln('│           QuickBBS : (1:387/609) (512)654-9134         │');
  122.     writeln('│                                                        │');
  123.     writeln('│     LZH/ZIP/PAK/ARC Conversion and Viewing Door        │');
  124.     writeln('│                   Version 1.23                         │');
  125.     writeln('│                                                        │');
  126.     writeln('│     VIEW LZH file                     CONVERT          │');
  127.     writeln('│     ─────────────                     ───────          │');
  128.     writeln('│  (L)ist                           (E) Self Extracting  │');
  129.     writeln('│  (V)iew                           (P) PAK file         │');
  130.     writeln('│  (O)ld style view                 (S) SEA  style ARC   │');
  131.     writeln('│  (D)isplay file inside a LHARC    (Z) Zip format       │');
  132.     writeln('│  (F)ile List                                           │');
  133.     writeln('│                                                        │');
  134.     writeln('│                  (Q)uit back to BBS                    │');
  135.     writeln('└────────────────────────────────────────────────────────┘');
  136.     write  (' Choice: ');
  137.   end;
  138.  
  139. procedure monomenu;
  140. begin
  141. writeln;
  142.   writeln('                  -= LHDOOR =-');
  143.   writeln('   LZH/ZIP/PAK/ARC Conversion and Viewing Door');
  144.   writeln('                 Version 1.23');
  145.   writeln;
  146.   writeln('  Support: RBBS-PC  : (1:387/301) (512)692-0377');
  147.   writeln('           QuickBBS : (1:387/609) (512)654-9134');
  148.   writeln;
  149.   writeln;
  150.   writeln('   VIEW LZH file                     CONVERT');
  151.   writeln('   ----                              -------');
  152.   writeln('(L)ist                           (E) Self Extracting');
  153.   writeln('(V)iew                           (P) PAK file');
  154.   writeln('(O)ld style view                 (S) SEA'' style ARC');
  155.   writeln('(D)isplay file inside a LHARC    (Z) Zip format');
  156.   writeln('(F)ile Listing');
  157.   writeln;
  158.   writeln('                (Q)uit back to BBS');
  159.   writeln;
  160.   write(' Choice: ');
  161. end;
  162.  
  163. Procedure QuickDisp;
  164. Var ii        : integer;
  165.     desc      : string[128];
  166.     iz        : integer;
  167.     Good_Area : boolean;
  168.     fbbs      : string[255];
  169.     psed      : char;
  170. begin
  171.   for ii := 1 to 5 do
  172.     writeln;
  173.   Assign(di,'FLSEARCH.CTL');
  174.   Good_Area := false;
  175.   While Not Good_Area do
  176.    begin
  177.     reset(di);
  178.     ii := 1;
  179.     While not eof(di) do
  180.       begin
  181.         ch:='z';
  182.         while ch <> ' ' do
  183.           read(di,ch);
  184.         while ch = ' ' do
  185.           read(di,ch);
  186.         Read(di,Set_Sec);
  187.         while ch = ' ' do
  188.           read(di,ch);
  189.         readln(di,desc);
  190.         If Set_Sec <= U_Security
  191.            then writeln('[',ii:3,']',' ',desc);
  192.         ii:=ii+1;
  193.       end;
  194.     ii:=ii-1;
  195.     Write('Which file area to list: ');
  196.     Readln(iz);
  197.     If (iz >= 1) and (iz <= ii)
  198.        then Good_Area := true;
  199.   end;
  200.   reset(di);
  201.   For ii := 1 to (iz-1) do
  202.     readln(di,ch);
  203.   fbbs:='';
  204.   While ch <> ' ' do
  205.     begin
  206.       read(di,ch);
  207.       if ch <> ' '
  208.          then fbbs:=fbbs+ch;
  209.     end;
  210.   close(di);
  211.   fbbs:=fbbs+'\FILES.BBS';
  212.   assign(di,fbbs);
  213.   {$I-}
  214.   reset(di);
  215.   {$I+}
  216.   if IORESULT <> 0
  217.      then begin
  218.             writeln('MISSING '+fbbs+'!! Please notify the sysop.');
  219.             halt(1);
  220.           end;
  221.   close(di);
  222.   Write('Do you want continuous (non-paused) output? ');
  223.   readln(psed);
  224.   if (psed='n') or (psed='N')
  225.      then Exec('C:\COMMAND.COM',' /C TYPE '+fbbs+' | MORE')
  226.      else Exec('C:\COMMAND.COM',' /C TYPE '+fbbs);
  227.   Writeln;
  228.   Write('Hit [Enter] to continue');
  229.   Readln;
  230. end;
  231.  
  232. procedure up_choice;
  233. var
  234.   ch : char;
  235. begin
  236.   ch := choice[1];
  237.   ch := upcase(ch);
  238.   choice := ch;
  239. end;
  240.  
  241. procedure get_file_name;
  242. var
  243.   dimwit : boolean;
  244. begin
  245.   dimwit := true;
  246.     while dimwit do
  247.     begin
  248.       write('          Enter the filename (No Extension) > ');
  249.       readln(Fname);
  250.       writeln;
  251.       dimwit :=false;  {intelligent until proven dimwitted}
  252.       if fname='' then
  253.         begin
  254.           writeln('Not a valid filename');
  255.           dimwit := true;
  256.         end
  257.       else begin
  258.              i := 1;
  259.              NewFile := '';
  260.              While (fname[i] <> '.') and (i <= Length(fname)) do
  261.                begin
  262.                  NewFile := NewFile + fname[i];
  263.                  i := i + 1;
  264.                end;
  265.              fname := NewFile;
  266.            end;
  267.       end;  {If they added an extension}
  268. end;
  269.  
  270. procedure find_file;
  271. begin
  272.     write('          Now searching for the file');
  273.     {$I-}
  274.       reset(paths);
  275.     {$I+}
  276.     if not(ioresult=0) then
  277.       begin
  278.         writeln;
  279.         writeln('Please Inform Sysop, FLSEARCH.CTL missing');
  280.         writeln('   ## Program Aborted - Exit Code 1 ##');
  281.         halt(1);
  282.       end;
  283.     file_found := false;
  284.     while (not(eof(paths)) and not(file_found)) do
  285.       begin
  286.         path := '';
  287.         ch := 'Y';
  288.         while ((ch <> ' ') and not(eof(paths))) do
  289.           begin
  290.             read(paths,ch);
  291.             if ch <> ' '
  292.               then path := path + ch;
  293.           end;
  294.         ch := '';
  295.         Readln(paths,Set_Sec);
  296.         if copy(path,length(path),1)='\' then path := copy(path,1,length(path)-1);
  297.         path := path + '\';
  298.         assign(fullfilename,path+fname+'.LZH');
  299.         {$I-}
  300.           reset(fullfilename);
  301.         {$I+}
  302.         if (IORESULT=0) and (Set_Sec <= U_Security)
  303.           then
  304.             file_found := TRUE
  305.           else
  306.               write('.');
  307.       end;
  308.     writeln;
  309. end;
  310.  
  311. PROCEDURE CHOICE_E;
  312.         begin
  313.           writeln;
  314.           writeln('          File located...');
  315.           writeln('          Creating self-extracting file now,  please hold...');
  316.           MkDir('\_$LHTMP');
  317.           ChDir('\_$LHTMP');
  318.           Exec('C:\COMMAND.COM',' /C LHARC s '+PATH+FNAME+' > NUL:');
  319.           Exec('C:\COMMAND.COM',' /C COPY '+FNAME+'.COM '+PATH+FNAME+'.COM >NUL');
  320.           Exec('C:\COMMAND.COM',' /C DEL '+FNAME+'.COM');
  321.           ChDir(Current);
  322.           RmDir('\_$LHTMP');
  323.           writeln('          The file is ',fname,'.COM, but is not listed.');
  324.           writeln('          It will be DELETED in the nightly event');
  325.           writeln('          so   -Get it NOW-');
  326.           Writeln;
  327.           Writeln('          Hit Enter to continue');
  328.           ReadLn;
  329.           assign(killarcs,'KILLARCS.BAT');
  330.           {$I-}
  331.           append(killarcs);
  332.           {$I+}
  333.           if not(ioresult=0) then rewrite(killarcs);
  334.           writeln(killarcs,'DEL ',path+fname,'.COM');
  335.           close(killarcs);
  336.         end;
  337.  
  338. procedure choice_VLOD;
  339. var
  340.   fspec   : string[255];
  341.   pausit  : string[1];
  342. begin
  343.           if choice='O' then Exec('C:\COMMAND.COM','/C LVIEW '+path+fname);
  344.           if choice='V' then Exec('C:\COMMAND.COM','/C LHARC V '+path+fname);
  345.           if choice='L' then Exec('C:\COMMAND.COM','/C LHARC L '+path+fname);
  346.           if choice='D' then
  347.             begin
  348.               Exec('C:\COMMAND.COM','/C LHARC L '+path+fname);
  349.               writeln('Enter the filespec you wish to VIEW or [ENTER] for all files');
  350.               write('within '+fname+': ');
  351.               readln(fspec);
  352.               write('Paused? ([Y]/n)');
  353.               readln(pausit);
  354.               writeln('        Please turn on CAPTURE now!');
  355.               writeln('        -------Begin Display-------');
  356.               if ((pausit='n') or (pausit='N'))
  357.                 then
  358.                   Exec('C:\COMMAND.COM',' /C LHARC P '+path+fname+' '+fspec+' | MORE')
  359.                 else
  360.                   Exec('C:\COMMAND.COM',' /C LHARC P '+path+fname+' '+fspec);
  361.               writeln('        --------End Display--------');
  362.             end;
  363.           Write('         Press [ENTER] to contine: ');
  364.           Readln;
  365. end;
  366.  
  367. procedure choice_spz;
  368.         begin
  369.           writeln;
  370.           write('File located - Now creating the archive in ');
  371.           if choice='S' then write ('ARC ');
  372.           if choice='P' then write ('PAK ');
  373.           if choice='Z' then write ('ZIP ');
  374.  
  375.           writeln('compatible format');
  376.           writeln('           Patience..');
  377.           assign(killarcs,'KILLARCS.BAT');
  378.           {$I-}
  379.             append(killarcs);
  380.           {$I+}
  381.           if not(ioresult=0) then rewrite(killarcs);
  382.           write(killarcs, 'DEL ',path+fname);
  383.           if choice='S' then writeln(killarcs,'.ARC');
  384.           if choice='P' then writeln(killarcs,'.PAK');
  385.           if choice='Z' then writeln(killarcs,'.ZIP');
  386.           close(killarcs);
  387.           {$I-}
  388.           Mkdir('\_$LHTMP');
  389.           {$I+}
  390.           if not(ioresult=0) then
  391.               writeln('Warning - Temporary Directory already Exists!');
  392.           {$I-}
  393.             Chdir('\_$LHTMP');
  394.           {$I+}
  395.           if not(ioresult=0) then
  396.             begin
  397.               writeln('Fatal Error - Unable to access Temporary Directory');
  398.               writeln('                 Exit Code 1');
  399.               halt(1);
  400.             end;
  401.           write('Clearing Work Directory..');
  402.           EXEC('C:\COMMAND.COM',' /C ECHO Y >Y');  {Avoids 'File Not Found'}
  403.           EXEC('C:\COMMAND.COM',' /C ECHO Y|DEL *.* >NUL');
  404.           Exec('C:\COMMAND.COM',' /C LHARC e /m '+PATH+FNAME);
  405.           If choice <> 'Z'
  406.              then CmdStr := 'PAK A /WA '
  407.              else CmdStr := 'PKZIP -A -EX ';
  408.           if choice = 'S' then CmdStr := CmdStr+'/C ';
  409.           CmdStr := CmdStr+path+Fname;
  410.             if choice='S' then cmdstr := cmdstr+'.ARC';
  411.             if choice='P' then cmdstr := cmdstr+'.PAK';
  412.             if choice='Z' then cmdstr := cmdstr+'.ZIP';
  413.           Exec('C:\COMMAND.COM',' /C '+CmdStr);
  414.           EXEC('C:\command.com',' /C ECHO Y|DEL *.* >NUL');
  415.           ChDir(Current);
  416.           {SI-}
  417.             RmDir('\_$LHTMP');
  418.           {$I+}
  419.           if not(ioresult=0) then
  420.             begin
  421.               writeln('Warning - Unable to remove temporary directory');
  422.               writeln('              Inform Sysop');
  423.             end;
  424.             writeln;
  425.           if Choice = 'Z' then
  426.                writeln('          Conversion complete, file is ',fname,'.ZIP.');
  427.           if Choice = 'S' then
  428.                writeln('          Conversion complete, file is ',fname,'.ARC.');
  429.           if Choice = 'P' then
  430.                writeln('          Conversion complete, file is ',fname,'.PAK.');
  431.                writeln('          It is available for download, but is not in');
  432.                writeln('          the file listings.');
  433.                writeln;
  434.                writeln('   NOTE: this file will be DELETED in the nightly event');
  435.                writeln('         You may return to the BBS and download at your');
  436.                writeln('         Convenience.');
  437.                writeln;
  438.                Writeln('                 Press [ENTER] to continue');
  439.                ReadLn;
  440.              end;
  441.  
  442. procedure not_found_msg;
  443.       begin
  444.         writeln;
  445.         writeln('          Sorry,  the file ',fname,'.LZH was not found on the disk');
  446.         writeln('          If this is the correct name then please inform the sysop of the');
  447.         writeln('          problem.  If this was not the correct name then please feel');
  448.         writeln('          free to try again.');
  449.         writeln;
  450.         write('Press [ENTER] ');
  451.         readln;
  452.         writeln;
  453.         writeln;
  454.       end;  {Bad file was entered}
  455.  
  456. procedure get_user_info;
  457. begin
  458.       Assign(di,'DORINFO1.DEF');
  459.       Reset(di);
  460.       for i := 1 to 9 do Readln(di, Dummy);
  461.       Readln(di,U_ANSI);
  462.       Readln(di,U_Security);
  463.       Close(di);
  464.       if QUICK_BBS then If U_ANSI=1 then U_ANSI := 2;
  465.       if PARAMCOUNT=0 then U_ANSI:=0;
  466. end;
  467.  
  468. {-------------------Main Loop-------------------}
  469.  
  470. begin
  471.   get_params;
  472.   while TRUE do
  473.     BEGIN
  474.       GetDir(0,Current);
  475.       get_user_info;
  476.       ValidChoice := False;
  477.       while not ValidChoice do
  478.         begin
  479.           ASSIGN (PATHS,'flsearch.ctl');
  480.           choice := 'Y';
  481.           while not ((choice='P') or
  482.                      (choice='D') or
  483.                      (choice='S') or
  484.                      (choice='Q') or
  485.                      (choice='V') or
  486.                      (choice='L') or
  487.                      (choice='E') or
  488.                      (choice='O') or
  489.                      (choice='F') or
  490.                      (choice='Z')) do
  491.             begin
  492.               if U_ANSI = 0 then monomenu;
  493.               if U_ANSI = 1 then graphmenu;
  494.               if U_ANSI = 2 then colormenu;
  495.               readln(choice);
  496.               up_choice;
  497.             end;
  498.  
  499.           IF CHOICE = 'Q' then HALT(0) else
  500.             begin
  501.               if choice='F'
  502.                  then if Quick_BBS then QuickDisp;
  503. {                 else if RBBS_BBS then RBBSDisp}  {temporarily commented}
  504.             if choice<>'F'
  505.                then begin
  506.                  get_file_name;
  507.                  find_file;
  508.                  if not(file_found) then not_found_msg;
  509.                  if (file_found) then
  510.                  if   choice='E'  then choice_E;
  511.                  if (((choice='V') or
  512.                      (choice='L') or
  513.                      (choice='O') or
  514.                      (choice='D')) and
  515.                      file_found) then CHOICE_VLOD;
  516.                  if (((choice='S') or
  517.                       (choice='P') or
  518.                       (choice='Z')) and
  519.                      file_found) then CHOICE_SPZ;
  520.                {$I-}
  521.                  close(paths);
  522.                {$I+}
  523.                end;
  524.             end;
  525.  
  526.         end;
  527.     end; {While not validchoice do}
  528. end.
  529.